#lang racket

(require "util/utils.scm")
(require "util/match-assoc.scm")
(provide pass-csans)

;; Mangling

(define (flatten lists) (apply append lists))

(define (quoted-string s)
  (let ((escape (lambda (khar)
                  (case khar
                    ((#\\) (list #\\ #\\))
                    ((#\") (list #\\ #\"))
                    ((#\newline) (list #\\ #\n))
                    (else (list khar))))))
    (list->string (append (list #\")
                          (flatten (map  escape (string->list s)))
                          (list #\")))))

(define (mangle-symbol sym)
  (let ((escape (lambda (khar)
                  (case khar
                    ((#\-) (string->list "_"))
                    ((#\>) (string->list "_to"))
		    ((#\<) (string->list "_lt"))
                    ((#\*) (string->list "_star"))
		    ((#\+) (string->list "_plus"))
		    ((#\=) (string->list "_eql"))
                    ((#\_) (string->list "_underscore"))
		    ((#\/) (string->list "_slash"))
                    ((#\?) (string->list "_question"))
                    ((#\!) (string->list "_bang"))
                    (else (list khar)))))
        (escape-keywords (lambda (l)
			   (match l
			     (`(#\c #\h #\a #\r) (append (list #\s #\y #\m #\_ ) l))
			     (`(#\s #\y #\m . ,l) (append (list #\s #\y #\m #\_ #\s #\y #\m) (cdddr l)))
			     (else l))))
                           ;(cond ((pattern? `(#\c #\h #\a #\r) l) (append (list #\s #\y #\m #\_ ) l))
                           ;      ((pattern? `(#\s #\y #\m ,char? ...) l) (append (list #\s #\y #\m #\_ #\s #\y #\m)
					;(cdddr l)))
					;      (else l))))
	(fixup (lambda (s)
		 (if (equal? "_bang" s)
		     "!"
		     s))))
    (fixup (list->string (escape-keywords (flatten (map escape (string->list (symbol->string sym)))))))))

;;;

(define (emit . stuff)
  (for-each display stuff)
  (newline))

(define (pass-csans program labels?)
  (match-assoc program (entry-point globals-size code)
    (emit "#include <stdio.h>")
    (emit "#include <stdlib.h>")
    (emit "#include <assert.h>")
    (emit "#include <string.h>")
    (emit "#include <errno.h>")
    (emit "#include \"sans.h\"")
    (emit "#include \"symboltable.h\"")
    (emit "#include \"stack.h\"")
    (emit "#include \"garbagecollector.h\"")
    (emit "#include \"runtime.h\"")
    (emit "sdata sans_glo[" (car globals-size) "];")
    (emit "sdata ret_reg;")
    (emit "sdata env_reg;")
    (emit "")
    (emit "int main(void) {")
    (emit "  sdata n;")
    (if labels?
        (emit "  goto label_" (car entry-point) ";")
        (begin
          (emit "  u label = " (car entry-point) ";")
          (emit "  while (1) {")
          (emit "    switch (label) {")))
    (mapply pass-csans-stmt code labels?)
    (if labels?
        #f
        (begin
          (emit "    }")
          (emit "  }")))
    (emit "}")))


(define (emit-label l labels?)
  (if labels?
      (emit "label_" l ":")
      (emit "case " l ":")))

(define (emit-goto l labels?)
  (if labels?
      (if (eq? 'label (car l))
          (emit "goto label_" (cadr l) ";")
          (emit "goto *(void*)" (cadr l) ";"))
      (begin
        (emit "label = " (cadr l) ";")
        (emit "break;"))))

(define (display-label l labels?)
  (if labels?
      (begin (display "(u)&&label_") (display l))
      (display l)))

(define (sp) (display "    "))
(define (pass-csans-stmt stmt labels?)
  (match stmt
    (`(label ,n)
     (sp) (emit "")
     (sp) (emit-label n labels?))
    (`(exit) (emit "exit(0);"))

    (`(move! (variable stk ,i) ,val)
     (sp)
     (display "stack_set(")
     (display i)
     (display ", ")
     (pass-csans-val val labels?)
     (display ");")
     (newline))
    ;; (move! (return-register) (builtin car (variable stk 0)))
    (`(move! ,place ,val)
     (sp)
     (pass-csans-place place)
     (display " = ")
     (pass-csans-val val labels?)
     (display ";")
     (newline))

    (`(shrink-stack ,h)
     (sp) (emit "stack_shrink(" h ");"))
    (`(extend-stack ,h)
     (sp) (emit "stack_grow(" h ");"))
    (`(stack-fold ,w ,d)
     (sp) (emit "stack_fold(" w "," d ");"))

    (`(return)
     (sp) (emit "env_reg = stack_pop();")
     (sp) (emit "n = stack_pop();")
     (sp) (emit "assert(n.tag == tlabl);")
     (sp) (emit-goto `(place "n.data.value") labels?))

    (`(branch ,v ,l)
     (sp) (display "n = ") (pass-csans-val v labels?) (emit ";")
     (sp) (display "if(n.tag == tbool && n.data.value == 0) {")
     (sp) (emit-goto `(label ,l) labels?)
     (sp) (emit "}"))
    
    (`(jump ,l)
     (sp) (emit-goto `(label ,l) labels?))

    (`(push! ,v)
     (sp) (display "stack_push(") (pass-csans-val v labels?) (emit ");"))

    (`(call)
     (sp) (emit "assert(ret_reg.tag == tclos);")
     ;;
     (sp) (emit "env_reg = heap_ref(ret_reg.data.value+1);")
     ;;
     (sp) (emit "ret_reg = heap_ref(ret_reg.data.value);")
     (sp) (emit "assert(ret_reg.tag == tlabl);")
     (sp) (emit-goto `(place "ret_reg.data.value") labels?))

    (`(closure-set! ,cl ,i ,val)
     (sp) (display "closure_set(")
     (pass-csans-val cl labels?)
     (display ", ")
     (display i)
     (display ", ")
     (pass-csans-val val labels?)
     (display ");")
     (newline))
    
    (else (error 'pass-csans-stmt "unhandled statement" stmt))))

(define (pass-csans-place p)
  (match p
    (`(return-register) (display "ret_reg"))
    (`(variable glo ,i)
     (display "sans_glo[")
     (display i)
     (display "]"))
    (else (error 'pass-csans-place "Unknown place" p))))

(define (pass-csans-val v labels?)
  (match v
    (`(atomic ,x)
     (cond ((boolean? x)
	    (display "(SDBOOL(") (display (if x 1 0)) (display "))"))
           ((number? x)
            (display "(SDNUMB(") (display x) (display "))"))

           ((char? x)
            (display "(SDCHAR(") (display (char->integer x)) (display "))"))

	   ((symbol? x)
	    (display "(sdata){.tag = tsymb, .data.value = ")
	    (display "intern(\"")
	    (display x) ;; TODO: stringify
	    (display "\")")
	    (display "}"))
	   
	   ((null? x)
	    (display "(sdata){.tag = tnull }"))

	   ((string? x)
            (display "allocate_string(\"")
            (display x)
            (display "\")"))
	   
	   (else (error 'pass-csans-val "unknown atomic type" x))))

    (`(label ,l)
     (display "(sdata){.tag = tlabl, .data.ivalue = ")
     (display-label l labels?)
     (display "}"))

    (`(return-register) (display "ret_reg"))
    (`(env-register) (display "env_reg"))
    
    (`(builtin ,f . ,args)
     (display "bltn_") (display (mangle-symbol f))
     (display "(")
     (unless (null? args)
       (pass-csans-val (car args) labels?)
       (for-each (lambda (a)
		   (display ", ")
		   (pass-csans-val a labels?))
		 (cdr args)))
     (display ")"))
    
    (`(closure ,s (label ,i))
     (display "allocate_closure(")
     (display s)
     (display ", ")
     (display-label i labels?)
     (display ")"))
    
    (`(variable stk ,i)
     (display "stack_ref(")
     (display i)
     (display ")"))
    (`(variable env ,i)
     (display "bltn_vector_ref(env_reg, SDNUMB(")
     (display i)
     (display "))"))
    (`(variable glo ,i)
     (display "sans_glo[")
     (display i)
     (display "]"))
    
    
    (else (error 'pass-csans-val "Unknown val" v))))

